home *** CD-ROM | disk | FTP | other *** search
/ Super CD / Super CD.iso / geomitri / acad10 / project.lsp < prev    next >
Lisp/Scheme  |  1988-09-08  |  13KB  |  442 lines
  1. ;                            PROJECT.LSP
  2.  
  3. ; Allows a "flat" projection of wireframe 3D models (lines, arcs,
  4. ; circles, polylines, solids, points) onto the current UCS.  This
  5. ; could be a useful aid for generating working drawings from a 3D 
  6. ; model.  3dmeshes will not be projected; Width information will 
  7. ; not be projected for polylines; Extrusion information will not
  8. ; be projected.  Entities not capable of projection will be 
  9. ; highlighted and tallied.
  10.  
  11. ; After projection, the user is allowed to make the projection
  12. ; into a block, or write it out as a drawing file.  These blocks or
  13. ; drawing files (typically Top, Front, Side, and Iso projections)
  14. ; could be re-inserted onto a single UCS and annotated to create a
  15. ; multi-view orthographic drawing.
  16.  
  17. ; The prompt sequence is:
  18.  
  19. ;  Select entities:  {do so}
  20. ;  Project more entities? <N>:  {Y or N}
  21. ;  Make projected entity(s) into a block? <N>:  {Y or N}
  22. ;  Write projected entities to disk as DWG file? <N>:  {Y or N}
  23.  
  24. ; Written by Jerry Ford & Brad Zehring
  25. ; Autodesk Training Department  8/18/88
  26.  
  27. ;----- Standard Error Function ---------------------------------
  28.  
  29. (defun projerr (st)
  30.  (if (/= st "Function cancelled")
  31.     (princ (strcat "\nError: "s))
  32.  )
  33.  (moder)
  34.  (setq *error* olderr)
  35.  (princ)
  36. )
  37.  
  38. ;----- Mode Save -- Saves designated system variables in a list ---
  39.  
  40. (defun MODES (a)
  41.    (setq MLST '())
  42.    (repeat (length a)
  43.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  44.       (setq a (cdr a)))
  45. )
  46. ;----- Mode Reset -- Resets previously saves system variables ---
  47.  
  48. (defun MODER ()
  49.    (repeat (length MLST)
  50.       (setvar (caar MLST) (cadar MLST))
  51.       (setq MLST (cdr MLST))
  52.    )
  53. )
  54.  
  55. ;----- Converts radians to degrees ------------------------------
  56.  
  57. (defun rtd (r)
  58.  (* 180 (/ r pi))
  59. )
  60.  
  61. ;----- Project LINE ---------------------------------------------
  62.  
  63. (defun lines-pro (/ stpt endpt)
  64.  (setq
  65.   stpt (trans (cdr (assoc 10 elist)) 0 1)
  66.   endpt (trans (cdr (assoc 11 elist)) 0 1)
  67.  )
  68.  (command "line"
  69.   (list (car stpt) (cadr stpt) 0)
  70.   (list (car endpt) (cadr endpt) 0)
  71.   ""
  72.  )
  73.  (setq entset (ssadd (entlast) entset))
  74. )
  75.  
  76. ;-----Project CIRCLE -- circle will be projected as curve fit polyline
  77. ; derive 0.3490658504 with (* pi (/ 1.0 9.0))
  78.  
  79. (defun circ-pro (/ pntlst center radius p-coord p-ctr)
  80.  (setq 
  81.   radius (cdr (assoc 40 elist))
  82.   center (cdr (assoc 10 elist))
  83.   p-ctr 0
  84.   pntlst '("c")  ;initialize point list for PLINE command
  85.  )
  86.  (while (< p-ctr 18)
  87.   (setq p-coord
  88.     (trans 
  89.       (polar center (* p-ctr 0.3490658504) radius)
  90.       ename 1
  91.     )
  92.   )
  93.   (setq p-coord
  94.      (list (car p-coord) (cadr p-coord) (cddr center))
  95.   )
  96.   (setq pntlst  ;build point list
  97.     (cons
  98.       (list 'quote (list (car p-coord) (cadr p-coord)))
  99.       pntlst
  100.     )
  101.   )
  102.   (setq p-ctr (1+ p-ctr))
  103.  )
  104.  (eval (append '(command "pline") pntlst)) ;feed in one COMMAND call
  105.  (command "pedit" "l" "f" "x")
  106.  (setq entset (ssadd (entlast) entset))
  107. )
  108.  
  109. ;----- Project ARC -- arc will be projected as curve fit polyline
  110. ; derive 6.2831853072 with (* 2 pi)
  111.  
  112. (defun arc-pro (/ center radius st-ang end-ang)
  113.  (setq center (cdr (assoc 10 elist))
  114.        radius (cdr (assoc 40 elist))
  115.        st-ang (cdr (assoc 50 elist))
  116.        end-ang (cdr (assoc 51 elist))
  117.  )
  118.  (command "pline")
  119.  (arc-draw center radius st-ang end-ang)
  120. )
  121.  
  122. (defun arc-draw (center radius st-ang end-ang
  123.                  / pt-num incl-ang angmult p-ctr)
  124.  (setq incl-ang (- end-ang st-ang) p-ctr 0)
  125.  (if (< incl-ang 0) (setq incl-ang (+ 6.2831853072 incl-ang)))
  126.  (setq pt-num (fix (+ 1 (/ incl-ang 0.3927)))) ;set # of pline vertex's
  127.  (if (< pt-num 4) (setq pt-num 4)) ;minimum # of vertex
  128.  (setq angmult (/ incl-ang (- pt-num 1)))
  129.  (while (< p-ctr pt-num)
  130.   (setq p-coord
  131.     (trans
  132.       (polar center (+ st-ang (* p-ctr angmult)) radius)
  133.       ename 1
  134.     )
  135.   )
  136.   (setq p-coord
  137.     (list (car p-coord) (cadr p-coord) (cddr center))
  138.   )
  139.   (command (list (car p-coord) (cadr p-coord)))
  140.   (setq p-ctr (1+ p-ctr))
  141.  )
  142.  (command "") (command "pedit" "l" "f" "x")
  143.  (setq entset (ssadd (entlast) entset))
  144. )
  145.  
  146. ;----- Project PLINE -- polyline will be projected as polyline
  147.  
  148. (defun pline-pro (/ 2dor3d bit-70 closed)
  149.   (setq 2dor3d nil)
  150.   (setq bit-70 (cdr (assoc 70 elist))) ;type of polyline?
  151.   (if (equal 0 (boole 1 bit-70 1))                    ;test for closure
  152.       (setq closed nil)
  153.       (setq closed (cdr (assoc 10 (entget (entnext ename)))))
  154.   )
  155.   (cond ((= (boole 1 bit-70 8) 8) (setq 2dor3d 0) (pline-dr)); space poly?
  156.         ((= 16 (boole 1 bit-70 16)) (setq reject-ent (ssadd ename reject-ent)));mesh?
  157.         (t (setq 2dor3d ename) (pline-dr));must be 2D poly
  158.   )
  159. )
  160.  
  161. (defun pline-dr (/ subname sublist sub-etype bulge v-coord
  162.                    sp ep center radius st-ang end-ang)
  163.   (setq subname (entnext ename))
  164.   (setq sublist (entget subname))
  165.   (command "pline")
  166.   (while (eq (setq sub-etype (cdr (assoc 0 sublist))) "VERTEX")
  167.    (if (/= (logand (cdr (assoc 70 sublist)) 16) 16) ;spline frame?
  168.      (progn
  169.        (if (/= (setq bulge (cdr (assoc 42 sublist))) 0) ;bulge?
  170.         (progn
  171.          (setq v-coord (trans (cdr (assoc 10 sublist)) 2dor3d 1))
  172.          (setq v-coord (list (car v-coord) (cadr v-coord)))
  173.          (command v-coord) (command)
  174.          (setq entset (ssadd (entlast) entset))
  175.          (setq sp (cdr (assoc 10 sublist)))
  176.          (if (setq ep (cdr (assoc 10 (entget (entnext subname)))))
  177.            (progn
  178.             (cvtbulge sp ep bulge)
  179.             (command "pline")
  180.             (arc-draw center radius st-ang end-ang)
  181.             (command "pline")
  182.            )
  183.            (if closed
  184.              (progn
  185.               (setq ep closed)
  186.               (cvtbulge sp ep bulge)
  187.               (command "pline")
  188.               (arc-draw center radius st-ang end-ang)
  189.               (setq closed nil)
  190.              )
  191.              (command)
  192.            )
  193.          )
  194.         )
  195.         (progn
  196.          (setq v-coord (trans (cdr (assoc 10 sublist)) 2dor3d 1))
  197.          (setq v-coord (list (car v-coord) (cadr v-coord)))
  198.          (command v-coord)
  199.         )
  200.        )
  201.      )
  202.    )
  203.    (setq subname (entnext subname))
  204.    (setq sublist (entget subname))
  205.   )
  206.   (if closed
  207.       (progn
  208.          (setq v-coord (trans closed 2dor3d 1))
  209.          (setq v-coord (list (car v-coord) (cadr v-coord)))
  210.          (command v-coord)
  211.          (command)
  212.       )
  213.       (command)
  214.   )
  215.   (setq entset (ssadd (entlast) entset))
  216. )
  217.  
  218. ;----- Project 3DFACE -- face will be projected as 1 polyline ---
  219.  
  220. (defun face-pro (/ c-type corner)
  221.  (setq c-type 10)
  222.  (setq pntlst '("c"))
  223.  (while (< c-type 14)
  224.   (setq corner (trans (cdr (assoc c-type elist)) 0 1))
  225.   (setq pntlst
  226.    (cons (list 'quote (list (car corner) (cadr corner) 0)) pntlst)
  227.   )
  228.   (setq c-type (+ 1 c-type))
  229.  )
  230.  (eval (append '(command "pline") pntlst))
  231.  (setq entset (ssadd (entlast) entset))
  232. )
  233.  
  234. ;----- Project SOLID -- solid will be projected as 1 polyline ----
  235.  
  236. (defun solid-pro (/ c-type pntlst)
  237.  (setq pntlst '("c")) ;initialize point list for SOLID command
  238.  (setq c-type 10) (findcorner)
  239.  (setq c-type 11) (findcorner)
  240.  (setq c-type 13) (findcorner)
  241.  (setq c-type 12) (findcorner)
  242.  (eval (append '(command "pline") pntlst))  ;feed in one COMMAND call
  243.  (setq entset (ssadd (entlast) entset))
  244. )
  245.  
  246. (defun findcorner (/ corner)
  247.   (setq corner (trans (cdr (assoc c-type elist)) ename 1))
  248.   (setq pntlst  ;build point list
  249.    (cons (list 'quote (list (car corner) (cadr corner))) pntlst)
  250.   )
  251. )
  252.  
  253. ;----- Project POINT ----------------------------------
  254.  
  255. (defun point-pro (/ pt)
  256.  (setq pt (trans (cdr (assoc 10 elist)) 0 1))
  257.  (command "point" (list (car pt) (cadr pt) 0))
  258.  (setq entset (ssadd (entlast) entset))
  259. )
  260.  
  261. ;----- Project all entities ---------------------------
  262.  
  263. (defun proj-ent (/ ctr entities setlength ename elist n-of-ents)
  264.  (prompt "\nExtrusion and mesh information will not be projected. ")
  265.  (setq ctr 0)
  266.  (setq entities (ssget))
  267.  (setq setlength (sslength entities))
  268.  (while (setq ename (ssname entities ctr))
  269.    (setq elist (entget ename)
  270.          etype (cdr (assoc 0 elist))
  271.    )
  272.    (cond ((or (eq etype "LINE") (eq etype "3DLINE")) (lines-pro))
  273.          ((eq etype "CIRCLE") (circ-pro))
  274.          ((eq etype "ARC") (arc-pro))
  275.          ((eq etype "POLYLINE" ) (pline-pro))
  276.          ((eq etype "3DFACE") (face-pro))
  277.          ((eq etype "POINT") (point-pro))
  278.          ((or (eq etype "TRACE") (eq etype "SOLID")) (solid-pro))
  279.          (T (setq reject-ent (ssadd ename reject-ent)))
  280.    )
  281.    (setq ctr (+ ctr 1))
  282.  )
  283.  (setq n-of-ents (sslength reject-ent))
  284.  (princ (strcat "\n" (itoa n-of-ents) " entities not projected"))
  285.  (redraw-rej)
  286. )
  287.  
  288. ;----- Redraw rejected entities --------------------------
  289.  
  290. (defun redraw-rej (/ r-ctr)
  291.   (setq r-ctr 0)
  292.   (while (> n-of-ents r-ctr)
  293.     (redraw (ssname reject-ent r-ctr) 3)
  294.     (setq r-ctr (1+ r-ctr))
  295.   )
  296. )
  297.  
  298. ;----- Make BLOCK from projected entities ----------------
  299.  
  300. (defun make-blk (/ blknam blkflg ip)
  301.  (setq blknam (getstring "\nBlock name: "))
  302.  (setq blkflg "")  ;initialize flag to redefine exist block
  303.  (if
  304.    (tblsearch "BLOCK" blknam)
  305.    (while
  306.      (and (tblsearch "BLOCK" blknam) (not (eq blkflg "Y")))
  307.      (prompt (strcat "\nBlock " blknam " already exists. "))
  308.      (setq blkflg (strcase (getstring "\nRedefine it? <N>: ")))
  309.      (if
  310.        (not (eq blkflg "Y"))
  311.        (setq blknam (getstring "\Block name: "))
  312.      )
  313.    )
  314.  )
  315.  (setq ip (getpoint "\nInsertion point <UCS 0,0,0>: "))
  316.  (if (not ip) (setq ip '(0 0 0)))
  317.  (if
  318.    (eq blkflg "Y")
  319.    (command "block" blknam "Y" ip entset "")
  320.    (command "block" blknam ip entset "")
  321.  )
  322. )
  323.  
  324. ;----- Write projected entities to disk as DWG file ------
  325.  
  326. (defun write-blk (/ flname dwgflg filept ip)
  327.  (setq flname (getstring "\nFile name: "))
  328.  (setq dwgflg "")  ;initialize flag to redefine exist file
  329.  (if  ;file of same name?
  330.    (setq filept (open (strcat flname ".DWG") "r"))
  331.    (progn
  332.      (setq filept (close filept))  ;close file
  333.      (while
  334.        (and 
  335.          (setq filept (open (strcat flname ".DWG") "r"))
  336.          (not (eq dwgflg "Y"))
  337.        )
  338.        (prompt (strcat "\nFile " flname " already exists. "))
  339.        (setq dwgflg (strcase (getstring "\nOverwrite it? <N>: ")))
  340.        (if
  341.          (not (eq dwgflg "Y"))
  342.          (progn
  343.            (setq filept (close filept))
  344.            (setq flname (getstring "\File name: "))
  345.          )
  346.          (setq filept (close filept))
  347.        )
  348.      )
  349.    )
  350.  )
  351.  (setq ip (getpoint "\nInsertion point <UCS 0,0,0>: "))
  352.  (if (not ip) (setq ip '(0 0 0)))
  353.  (if
  354.    (eq dwgflg "Y")
  355.    (command "wblock" flname "Y" "" ip entset "")
  356.    (command "wblock" flname "" ip entset "")
  357.  )
  358. )
  359. ;--------- Convert bulge information -------------------
  360. ; AutoLISP function to convert from Polyline "Bulge" representation
  361. ; of an arc to AutoCAD's normal "center, radius, start/end angles"
  362. ; form of arc.  This function applies the bulge between two adjacent
  363. ; vertices.  It assumes that global symbols "sp", "ep", and "bulge"
  364. ; contain the current vertex (start point), next vertex (end point),
  365. ; and bulge, respectively.  It sets the appropriate values in global
  366. ; symbols "center", "radius", "st-ang", and "end-ang".
  367.  
  368. ; by Duff Kurland - Autodesk, Inc.
  369. ; July 7, 1986
  370.  
  371.  
  372. (defun cvtbulge (sp ep bulge / x1 x2 y1 y2 cotbce)
  373.   (setq x1 (car  sp) x2 (car  ep))
  374.   (setq y1 (cadr sp) y2 (cadr ep))
  375.   (setq cotbce (/ (- (/ 1.0 bulge) bulge) 2.0))
  376.  
  377.   ; Compute center point and radius
  378.  
  379.   (setq center (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
  380.                      (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
  381.                      (caddr sp)
  382.                )
  383.   )
  384.   (setq radius (distance center sp))
  385.  
  386.   ; Compute start and end angles
  387.  
  388.   (setq st-ang  (atan (- y1 (cadr center)) (- x1 (car center))))
  389.   (setq end-ang  (atan (- y2 (cadr center)) (- x2 (car center))))
  390.   (if (< st-ang 0.0)                      ; Eliminate negative angles
  391.      (setq st-ang (+ st-ang (* 2.0 pi)))
  392.   )
  393.   (if (< end-ang 0.0)
  394.      (setq end-ang (+ end-ang (* 2.0 pi)))
  395.   )
  396.   (if (< bulge 0.0)                   ; Swap angles if clockwise
  397.      (progn
  398.         (setq temp st-ang)
  399.         (setq st-ang end-ang)
  400.         (setq end-ang temp)
  401.      )
  402.   )
  403. )
  404.  
  405. ;----- Select entities, test for entity type and call approprite function
  406.  
  407. (defun C:PROJECT (/ olderr reject-ent entset)
  408.  (setq olderr *error* *error* projerr)
  409.  (modes '("cmdecho" "blipmode" "expert" "flatland"))
  410.   (mapcar 'setvar
  411.           '("cmdecho" "blipmode" "expert" "flatland")
  412.           '(0 0 1 0)
  413.   )
  414.  (setq reject-ent (ssadd))
  415.  (setq entset (ssadd))
  416.  
  417.  (proj-ent)
  418.  (while  ;continue projecting more selection sets?
  419.    (eq (strcase (getstring "\nProject more entities? <N>: ")) "Y")
  420.    (proj-ent)
  421.  )
  422.  (cond
  423.    ((eq (strcase
  424.         (getstring "\nMake projected entity(s) into block? <N>: ")
  425.         ) "Y"
  426.     )
  427.     (make-blk)
  428.    )
  429.    ((eq (strcase
  430.     (getstring "\nWrite projected entity(s) to disk as DWG file? <N>: ")
  431.         ) "Y"
  432.     )
  433.     (write-blk)
  434.    )
  435.    (T)
  436.  )
  437.  (moder)
  438.  (setq *error* olderr)
  439.  (princ)
  440. )
  441.  
  442.